home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / link / pmax_link.t < prev    next >
Text File  |  1989-06-30  |  12KB  |  346 lines
  1. (herald pmax_link (env t (link defs)))
  2.  
  3. ;;; Look at a Unix a.out description and template.doc
  4.  
  5. (define (link modules out-spec)
  6.   (really-link modules 'mlo out-spec 'o))
  7.  
  8. (define-constant RELOC-SIZE 8)
  9. (define-constant MAGIC #x162)
  10. (define-constant TEXT-SYM 1)
  11. (define-constant DATA-SYM 3)
  12.  
  13. (lset reloc-length 0)
  14. (lset pure-size 0)
  15.  
  16. (define (write-vcell-header var stream)
  17.   (write-byte stream (if (eq? (var-node-defined var) 'define)
  18.              (fx+ header/vcell 128)
  19.              header/vcell))
  20.   (write-byte stream 0)
  21.   (write-byte stream (if (fx= (vector-length (var-node-refs var))
  22.                   0)
  23.              0
  24.              -1))
  25.   (write-byte stream 0))
  26.     
  27. (define-constant %%d-ieee-size 53)
  28. (define-constant %%d-ieee-excess 1023)
  29.  
  30. (define (write-double-float stream float)
  31.   (receive (sign mantissa exponent)
  32.            (normalized-float-parts float
  33.                                    %%d-ieee-size 
  34.                                    %%d-ieee-excess 
  35.                                    t)
  36.     (write-int stream header/double-float)
  37.     (write-half stream (bignum-bit-field mantissa 0 16)) 
  38.     (write-half stream (bignum-bit-field mantissa 16 16))
  39.     (write-half stream (bignum-bit-field mantissa 32 16))
  40.     (write-half stream (fx+ (fixnum-ashl sign 15)
  41.                             (fx+ (fixnum-ashl exponent 4)
  42.                                  (bignum-bit-field mantissa 48 4)))))) 
  43.   
  44.  
  45. (define (vgc-copy-foreign foreign)
  46.   (let* ((heap (lstate-impure *lstate*))
  47.          (addr (area-frontier heap))
  48.          (name (foreign-object-name foreign))
  49.          (desc (object nil
  50.                  ((heap-stored self) (lstate-impure *lstate*))
  51.                  ((heap-offset self) addr)
  52.                  ((write-descriptor self stream)
  53.                   (write-data stream (fx+ addr tag/extend)))
  54.                  ((write-store self stream)
  55.                   (write-int stream header/foreign)
  56.                   (write-slot name stream)
  57.                   (write-int stream 0)))))
  58.     (set (area-frontier heap) (fx+ addr 12))
  59.     (set-table-entry *reloc-table* foreign desc)
  60.     (generate-slot-relocation name (fx+ addr 4))
  61.     (push (area-objects heap) desc)                
  62.     (cymbal-thunk (symbol->string name) 0)
  63.     (reloc-thunk (fx+ addr 8) (lstate-symbol-count *lstate*) #x90)
  64.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  65.     desc))
  66.  
  67. (define (relocate-unit-variable var addr external?)
  68.   (let ((area (lstate-impure *lstate*))
  69.         (type (var-value-type var)))
  70.    (cond (type
  71.     (cond ((and external? (neq? (var-node-value var) NONVALUE))
  72.            (cymbal-thunk (string-downcase! (symbol->string (var-node-name var)))
  73.                          (unit-var-value (var-node-value var)))
  74.            (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  75.     (if (fx= type DATA-SYM)
  76.         (reloc-thunk addr DATA-SYM #x10)
  77.         (reloc-thunk addr TEXT-SYM #x10))))))
  78.  
  79.  
  80. (define (var-value-type var)
  81.   (let ((value (var-node-value var)))
  82.     (cond ((eq? value NONVALUE) 
  83.            (vgc (var-node-name var))
  84.            nil)
  85.           ((unit-loc? value) DATA-SYM)
  86.           (else
  87.            (let ((desc (vgc value)))
  88.              (if (eq? (heap-stored desc) (lstate-impure *lstate*))
  89.                  DATA-SYM                                                                
  90.                  TEXT-SYM))))))
  91.  
  92. (define (generate-slot-relocation obj slot-address)
  93.   (cond ((or (fixnum? obj) (char? obj) (eq? obj '#t)))
  94.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  95.          (reloc-thunk slot-address DATA-SYM #x10))
  96.         (else
  97.          (reloc-thunk slot-address TEXT-SYM #x10))))
  98.  
  99. (define (text-relocation addr)
  100.   (reloc-thunk addr TEXT-SYM #x10))
  101.  
  102. (define (data-relocation addr)
  103.   (reloc-thunk addr DATA-SYM #x10))
  104.  
  105. (define (reloc-thunk address lw hb)
  106.   (push (lstate-data-reloc *lstate*)
  107.         (cons address (cons lw hb))))
  108.             
  109. (lset the-string-table nil)
  110.  
  111. (define (cymbal-thunk stryng value)
  112.  (push (lstate-symbols *lstate*)
  113.   (object (lambda (stream)
  114.         (write-int stream 0)
  115.         (write-int stream (table-entry the-string-table stryng))
  116.             (cond ((fx= value 0)            ; undefined external (foreign)
  117.            (write-int stream 0)
  118.            (write-half stream #xf181))
  119.           (else
  120.            (write-data stream value)
  121.            (write-half stream #xf081)))
  122.         (write-half stream #xffff))
  123.           ((cymbal-thunk.stryng self) stryng))))
  124.  
  125. (define-operation (cymbal-thunk.stryng thunk))
  126.  
  127.  
  128. (define (write-slot obj stream)
  129.   (cond ((table-entry *reloc-table* obj)
  130.          => (lambda (desc) (write-descriptor desc stream)))
  131.         ((fixnum? obj)
  132.          (write-fixnum stream obj))
  133.         ((char? obj)
  134.          (write-int stream (fx+ (fixnum-ashl (char->ascii obj) 8)
  135.                                  header/char)))
  136.         ((eq? obj '#t)
  137.          (write-int stream header/true))
  138.         (else
  139.          (error "bad immediate type ~s" obj))))
  140.  
  141. (define-integrable (write-data stream int)
  142.   (write-int stream (fx+ pure-size int)))
  143.  
  144. (define (write-int stream int)
  145.   (write-half stream int)
  146.   (let ((int (fixnum-ashr int 16)))
  147.     (write-half stream int)))
  148.  
  149. (define (write-half stream int)
  150.   (write-byte stream int)
  151.   (let ((int (fixnum-ashr int 8)))
  152.     (write-byte stream int)))
  153.  
  154. (define-integrable (write-byte stream n)
  155.   (writec stream (ascii->char (fixnum-logand n 255))))
  156.  
  157. (define (write-fixnum stream fixnum)
  158.   (write-half stream (fixnum-ashl fixnum 2))
  159.   (write-half stream (fixnum-ashr fixnum 14)))
  160.  
  161.  
  162. (define (write-link-file stream)
  163.   (set reloc-length (enforce (lambda (x) (<= x #xffff))
  164.                  (length (lstate-data-reloc *lstate*))))
  165.   (modify (lstate-symbols *lstate*) reverse!)
  166.   (pad-area (lstate-pure *lstate*))
  167.   (pad-area (lstate-impure *lstate*))
  168.   (set pure-size (area-frontier (lstate-pure *lstate*)))
  169.   (write-header     stream)
  170.   (write-aouthdr stream)
  171.   (write-text-section-header stream)
  172.   (write-data-section-header stream)
  173.   (write-area       stream (lstate-pure *lstate*))
  174.   (write-area       stream (lstate-impure *lstate*))
  175.   (write-relocation stream)
  176.   (receive (i aligned-i) (make-stryng-table)
  177.     (write-cymbal-table-header stream aligned-i)
  178.     (write-hack-local-symbol stream)
  179.     (write-hack-local-string stream)
  180.     (write-stryng-table stream (fx- aligned-i i)))
  181.   (write-hack-file-descriptor stream)
  182.   (write-cymbal-table stream))
  183.  
  184. (define (write-header stream)
  185.     (write-half stream MAGIC)                 ;magic number
  186.     (write-half stream 2)                     ; # of sections
  187.     (write-int stream 0)                      ; time and date 
  188.     (write-int stream (cymbal-table-offset))
  189.     (write-int stream #x60)        ;size of symbol header
  190.     (write-half stream #x38)                      ; size of a.out header
  191.     (write-half stream 0))        ;flags
  192.  
  193. (define (write-aouthdr stream)
  194.   (write-half stream #x107)        ;magic
  195.   (write-half stream #x11f)        ;version stamp
  196.   (write-int stream (text-size))    ;text size
  197.   (write-int stream (data-size))    ;data size
  198.   (write-int stream 0)            ;bss size
  199.   (write-int stream 0)            ;entry
  200.   (write-int stream 0)            ;text base
  201.   (write-int stream (text-size))    ;data base
  202.   (write-int stream (+ (text-size) (data-size))) ;bss base
  203.   (write-int stream 0)            ;register mask
  204.   (write-int stream 0)            ;cp mask [4]
  205.   (write-int stream 0)
  206.   (write-int stream 0)
  207.   (write-int stream 0)
  208.   (write-int stream #x8010))        ;gp value ???
  209.  
  210.  
  211. (define (write-text-section-header stream)   
  212.   (write-string stream ".text")
  213.   (write-byte stream 0)
  214.   (write-byte stream #x20)
  215.   (write-byte stream #x20)
  216.   (write-int stream 0)      ; phys addr
  217.   (write-int stream 0)      ; virtual addr
  218.   (write-int stream (text-size))    
  219.   (write-int stream (headers-size))    ;offset in file
  220.   (write-int stream 0)      ; no reloc
  221.   (write-int stream 0)      ; no gp table
  222.   (write-int stream 0)      
  223.   (write-int stream #x20))
  224.   
  225. (define (write-data-section-header stream)   
  226.   (write-string stream ".data")
  227.   (write-byte stream 0)
  228.   (write-byte stream #x20)
  229.   (write-byte stream #x20)
  230.   (write-int stream (text-size))      ; phys addr
  231.   (write-int stream (text-size))      ; virtual addr
  232.   (write-int stream (data-size))    
  233.   (write-int stream (+ (text-size) (headers-size)))    ;offset in file
  234.   (write-int stream (+ (headers-size) (text-size) (data-size)))    ;  reloc
  235.   (write-int stream 0)      ; no gp table
  236.  
  237.   (write-int stream reloc-length)
  238.   (write-int stream #x40))
  239.  
  240. (define (headers-size) (fx* 39 4))
  241. (define (text-size) (area-frontier (lstate-pure *lstate*)))
  242. (define (data-size) (area-frontier (lstate-impure *lstate*)))
  243.  
  244. (define (cymbal-table-offset)
  245.   (+ (headers-size) (text-size) (data-size)
  246.      (* RELOC-SIZE reloc-length)))
  247.  
  248. (define (write-area stream area)
  249.   (walk (lambda (x) (write-store x stream))
  250.         (reverse! (area-objects area))))
  251.  
  252.  
  253. (define (write-relocation stream)
  254.   (walk (lambda (item)
  255.       (destructure (((addr . (lw .  hb)) item))
  256.         (write-data stream (car item))
  257.         (write-half stream lw)
  258.         (write-byte stream 0)
  259.         (write-byte stream hb)))
  260.         (sort-list! (lstate-data-reloc *lstate*)
  261.                     (lambda (x y)      
  262.                        (fx< (car x) (car y))))))
  263.  
  264.  
  265. (define (write-map-entry stream name value) nil)
  266.  
  267. (define (write-cymbal-table-header stream string-table-size)
  268.   (write-half stream #x7009)        ;magic
  269.   (write-half stream #x11f)        ;vstamp
  270.   (write-long-zeros stream 7)
  271.   (write-int stream 2)            ;number of local symbols
  272.   (write-int stream (+ (cymbal-table-offset) #x60))
  273.   (write-long-zeros stream 4)
  274.   (write-int stream 8)            ;max index in local strings
  275.   (write-int stream (+ (cymbal-table-offset) #x60 24))
  276.   (write-int stream string-table-size)    ;max string-index
  277.   (write-int stream (+ (cymbal-table-offset) #x60 8 24)) ;string table begin
  278.   (write-int stream 1)            ;fd entries
  279.   (write-int stream (+ (cymbal-table-offset) #x60 8 24 string-table-size))
  280.   (write-long-zeros stream 2)
  281.   (write-int stream (lstate-symbol-count *lstate*)) ;max symbol index
  282.   (write-int stream (+ (cymbal-table-offset) #x60 8 24 string-table-size 72)))
  283.  
  284. (define (write-hack-local-symbol stream)
  285.   (write-int stream 1)
  286.   (write-int stream 0)
  287.   (write-int stream #x204b)
  288.   (write-int stream 1)
  289.   (write-int stream 0)
  290.   (write-int stream #x48))
  291.  
  292.  
  293. (define (write-hack-local-string stream)
  294.   (write-byte stream 0)
  295.   (write-string stream "foo.s")
  296.   (write-byte stream 0)
  297.   (write-byte stream 0))
  298.  
  299. (define (write-hack-file-descriptor stream)
  300.   (walk (lambda (x) (write-int stream x))
  301.     '(0 1 0 7 0 2 0 0 0 0 0 0 0 0 0))
  302.   (write-int stream #x223)
  303.   (write-int stream 0)
  304.   (write-int stream 0))
  305.  
  306.  
  307. (define (write-long-zeros stream n)
  308.   (do ((i n (fx- i 1)))
  309.       ((fx= i 0))
  310.     (write-int stream 0)))
  311.  
  312. (define (write-cymbal-table stream)
  313.   (walk (lambda (cym) (cym stream)) (lstate-symbols *lstate*)))
  314.  
  315. (define (make-stryng-table)
  316.   (set the-string-table (make-string-table 'stryngs))
  317.   (iterate loop ((i 0) (cyms (lstate-symbols *lstate*)))
  318.       (cond ((null? cyms) (return i (align i 2)))
  319.             (else
  320.              (let* ((string (cymbal-thunk.stryng (car cyms)))
  321.                     (len (string-length string)))
  322.            (set (table-entry the-string-table string) i)
  323.            (loop (fx+ i (fx+ len 1)) (cdr cyms)))))))
  324.                                                        
  325.  
  326. (define (write-stryng-table stream extra)
  327.   (walk (lambda (cym)
  328.       (write-string stream (cymbal-thunk.stryng cym))
  329.       (write-byte stream 0))
  330.     (lstate-symbols *lstate*))
  331.   (do ((extra extra (fx- extra 1)))
  332.       ((fx= extra 0))
  333.     (write-byte stream 0)))
  334.  
  335.  
  336. (define (pad-area area)
  337.   (let ((rem (fixnum-remainder (area-frontier area) 16)))
  338.     (cond ((fxn= rem 0)
  339.        (modify (area-frontier area)
  340.            (lambda (x) (fx+ x (fx- 16 rem))))
  341.        (do ((i (fx- 16 rem) (fx- i 4)))
  342.            ((fx= i 0))
  343.          (push (area-objects area)
  344.            (object nil
  345.              ((write-store self stream)
  346.               (write-int stream 0)))))))))